home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload Trio 2
/
Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO
/
dir44
/
dungn32.zip
/
GAME.FOR
< prev
next >
Wrap
Text File
|
1994-10-08
|
12KB
|
309 lines
C Command loop, initialization for DUNGEON
C
C COPYRIGHT 1980, 1990, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA.
C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
C WRITTEN BY R. M. SUPNIK
C
C 17-Sep-94 RMS Fixed TELL/parse fail bug. Fixed VMS/UNIX
C compatibility problem.
C 30-Jan-94 RMS Fixed bugs from MS DOS port.
C 30-Jun-92 RMS Changed file names to lower case.
C
C GAME- Main command loop
C
C Declarations
C
SUBROUTINE GAME
IMPLICIT INTEGER (A-Z)
INCLUDE 'dparam.for'
LOGICAL RMDESC,VAPPLI,AAPPLI,OBJACT
LOGICAL F,PARSE,FINDXT,XVEHIC,LIT,PRVLIT
C GAME, PAGE 2
C
C Start up, describe current location.
C
CALL RSPEAK(1) ! welcome aboard.
F=RMDESC(3) ! start game.
C
C Now loop, reading and executing commands.
C
100 WINNER=PLAYER ! player moving.
TELFLG=.FALSE. ! assume nothing told.
IF(PRSCON.LE.1) CALL RDLINE(INBUF,INLNT,1) ! read command.
C
IF(INBUF(PRSCON:INLNT).NE.'GDT') GO TO 200 ! call on gdt?
CALL GDT ! yes, invoke.
PRSCON=1 ! force restart.
GO TO 100 ! onward.
C
200 MOVES=MOVES+1
SUBLNT=0 ! no substrings.
PRVHER=HERE ! save current location.
PRVLIT=LIT(HERE) ! save current lighting.
PRSWON=PARSE(INBUF,INLNT,.TRUE.) ! parse input, normal mode.
IF(.NOT.PRSWON) GO TO 400 ! parse lose?
IF(AAPPLI(AACTIO(WINNER))) GO TO 400 ! player handle?
IF(XVEHIC(1)) GO TO 400 ! vehicle handle?
C
IF(PRSA.EQ.TELLW) GO TO 2000 ! tell?
300 IF((PRSO.EQ.VALUA).OR.(PRSO.EQ.EVERY).OR.(PRSO.EQ.POSSE)
1.OR.(PRSO.EQ.BUNOBJ)) GO TO 900 ! collective object?
IF(.NOT.VAPPLI(PRSA)) GO TO 400 ! verb ok?
IF(.NOT.PRVLIT.AND.(HERE.EQ.PRVHER)
1.AND.LIT(HERE)) F=RMDESC(0) ! now lit
350 IF(.NOT.(ECHOF.OR.DEADF).AND.(HERE.EQ.ECHOR)) GO TO 1000
CALL RAPPLI(RACTIO(HERE)) ! room action?
C
400 CALL XENDMV(TELFLG) ! do end of move.
IF(.NOT.LIT(HERE)) PRSCON=1 ! if not lit, restart.
GO TO 100
C
900 CALL VALUAC(PRSO) ! collective object.
GO TO 350
C GAME, PAGE 3
C
C Special case-- Echo Room.
C If input is not 'ECHO' or a direction, just echo.
C
1000 CALL RDLINE(INBUF,INLNT,0) ! read line.
MOVES=MOVES+1 ! charge for moves.
IF(INBUF.NE.'ECHO') GO TO 1100 ! input = echo?
C
CALL RSPEAK(571) ! kill the echo.
ECHOF=.TRUE.
OFLAG2(BAR)=OFLAG2(BAR).AND. .NOT.SCRDBT ! let thief steal bar.
PRSWON=.TRUE. ! fake out parser.
PRSCON=1 ! force new input.
GO TO 400
C
1100 IF(INBUF.NE.'BUG') GO TO 1200 ! bug request?
CALL RSPEAK(913) ! wrong, jack.
GO TO 1000 ! try again.
C
1200 IF(INBUF.NE.'FEATURE') GO TO 1300 ! feature request?
CALL RSPEAK(914) ! right, jack.
GO TO 1000 ! try again
C
1300 PRSWON=PARSE(INBUF,INLNT,.FALSE.) ! parse input, echo mode.
IF(.NOT.PRSWON .OR. (PRSA.NE.WALKW))
1GO TO 1400 ! walk?
IF(FINDXT(PRSO,HERE)) GO TO 300 ! valid exit?
C
1400 WRITE(OUTCH,1410) INBUF(1:INLNT) ! echo input.
1410 FORMAT(1X,A)
TELFLG=.TRUE. ! indicate output.
GO TO 1000 ! more echo room.
C GAME, PAGE 4
C
C Special case-- TELL <ACTOR> "NEW COMMAND".
C Note that we cannot be in the Echo Room.
C
2000 IF(SUBLNT.NE.0) GO TO 2050 ! any substring?
CALL RSPSUB(946,ODESC2(PRSO)) ! no, joke.
GO TO 2150 ! done.
C
2050 IF(PRSO.NE.OPLAY) GO TO 2100 ! to self?
WRITE(OUTCH,2060) SUBBUF(1:SUBLNT) ! ok, tell it.
2060 FORMAT(' Ok: "',A,'".')
TELFLG=.TRUE.
GO TO 2150
C
2100 IF(OBJACT(X)) GO TO 350 ! object handle?
IF((OFLAG2(PRSO).AND.ACTRBT).NE.0) GO TO 2200 ! actor?
I=602
IF((OFLAG1(PRSO).AND.VICTBT).NE.0) I=888
CALL RSPSUB(I,ODESC2(PRSO)) ! no, joke.
2150 PRSCON=0 ! disable cmd stream.
GO TO 350
C
2200 SVPRSC=PRSCON ! save prscon.
SVPRSO=PRSO ! save prso.
PRSCON=1 ! start of substring.
2300 WINNER=OACTOR(SVPRSO) ! new player.
HERE=AROOM(WINNER) ! new location.
PRSWON=PARSE(SUBBUF,SUBLNT,.TRUE.) ! parse command.
IF(.NOT.PRSWON) GO TO 2600 ! parse succeed?
C
IF(AAPPLI(AACTIO(WINNER))) GO TO 2400 ! actor handle?
IF(XVEHIC(1)) GO TO 2400 ! vehicle handle?
IF((PRSO.EQ.VALUA).OR.(PRSO.EQ.EVERY).OR.(PRSO.EQ.POSSE)
1.OR.(PRSO.EQ.BUNOBJ)) GO TO 2900 ! collective object?
IF(.NOT.VAPPLI(PRSA)) GO TO 2400 ! verb handle?
2350 CALL RAPPLI(RACTIO(HERE)) ! room action?
2400 IF(PRSCON-1) 2700,2550,2500 ! parser reset?
2500 CALL XENDMV(TELFLG) ! more to do, end of move.
GO TO 2300 ! do next command.
C
2550 PRSCON=SVPRSC ! substring exhausted.
GO TO 2700 ! restore state.
C
2600 IF(OFLAG.NE.0) CALL RSPEAK(604) ! parse fails, orphans?
OFLAG=0 ! invalidate orphans.
2700 WINNER=PLAYER ! restore state.
HERE=AROOM(WINNER)
GO TO 400 ! rejoin main loop.
C
2900 CALL VALUAC(PRSO) ! collective object.
GO TO 2350
C
END
C XENDMV- Execute end of move functions.
C
C Declarations
C
SUBROUTINE XENDMV(FLAG)
IMPLICIT INTEGER (A-Z)
INCLUDE 'dparam.for'
LOGICAL F,CLOCKD,FLAG,XVEHIC
C
IF(.NOT.FLAG) CALL RSPEAK(341) ! default remark.
IF(THFACT) CALL THIEFD ! thief demon.
IF(PRSWON.AND..NOT.DEADF) CALL FIGHTD ! fight demon.
IF(SWDACT) CALL SWORDD ! sword demon.
IF(PRSWON) F=CLOCKD(X) ! clock demon.
IF(PRSWON) F=XVEHIC(2) ! vehicle readout.
RETURN
END
C XVEHIC- Execute vehicle function
C
C Declarations
C
LOGICAL FUNCTION XVEHIC(N)
IMPLICIT INTEGER (A-Z)
INCLUDE 'dparam.for'
LOGICAL OAPPLI
C
XVEHIC=.FALSE. ! assume loses.
AV=AVEHIC(WINNER) ! get vehicle.
IF(AV.NE.0) XVEHIC=OAPPLI(OACTIO(AV),N)
RETURN
END
C INITFL-- DUNGEON file initialization subroutine
C
C Declarations
C
LOGICAL FUNCTION INITFL(X)
IMPLICIT INTEGER (A-Z)
INCLUDE 'dparam.for'
LOGICAL PROTCT
CHARACTER*1 KEDIT
C INITFL, PAGE 2
C
C First check for protection violation.
C
INITFL=.FALSE. ! assume init fails.
IF(PROTCT(X)) GO TO 10000 ! protection violation?
WRITE(OUTCH,10100) ! yes, throw him off.
10100 FORMAT(
1' There appears before you a threatening figure clad all'/
1' over in heavy black armor. His legs seem like the massive'/
2' trunk of the oak tree. His broad shoulders and helmeted'/
3' head loom high over your own puny frame, and you realize'/
4' that his powerful arms could easily crush the very life'/
5' from your body. There hangs from his belt a veritable'/
6' arsenal of deadly weapons: sword, mace, ball and chain'/
7' dagger, lance, and trident. He speaks with a commanding'/
8' voice:'//20X,'"You shall not pass."'//
9' As he grabs you by the neck all grows dim about you.')
RETURN
C
C Now restore from existing index file.
C
10000 OPEN (UNIT=1,FILE='dindx.dat',STATUS='OLD',MODE='READ',
1FORM='FORMATTED',ACCESS='SEQUENTIAL',ERR=1900)
READ(1,130) I,J ! get version.
READ(1,125) KEDIT ! get minor edit.
IF((I.NE.VMAJ).OR.(J.NE.VMIN))
1GO TO 1925 ! match to ours?
C
OPEN (UNIT=DBCH,FILE='dtext.dat',STATUS='OLD',MODE='READ',
1FORM='UNFORMATTED',ACCESS='DIRECT',
2RECL=RECLNT,ERR=1950)
C
READ(1,130) MXSCOR,STRBIT,EGMXSC
READ(1,130) RLNT,RDESC2,RDESC1,REXIT,RACTIO,RVAL,RFLAG
READ(1,130) XLNT,TRAVEL
READ(1,130) OLNT,ODESC1,ODESC2,ODESCO,OACTIO,OFLAG1,OFLAG2,
1OFVAL,OTVAL,OSIZE,OCAPAC,OROOM,OADV,OCAN,OREAD
READ(1,130) R2LNT,O2,R2
READ(1,130) CLNT,CTICK,CACTIO
READ(1,135) CFLAG,CCNCEL
READ(1,130) VLNT,VILLNS,VPROB,VOPPS,VBEST,VMELEE
READ(1,130) ALNT,AROOM,ASCORE,AVEHIC,AOBJ,AACTIO,ASTREN,AFLAG
READ(1,130) MBASE,MLNT,RTEXT
C
CLOSE (UNIT=1)
GO TO 1025 ! init done.
C
125 FORMAT(A)
130 FORMAT(I8)
135 FORMAT(L4)
C INITFL, PAGE 3
C
C The internal data base is now established.
C Set up to play the game-- INITFL succeeds.
C
1025 CALL IDATE(SHOUR,SMIN,SSEC) ! get date (and toss).
I=(SHOUR*64)+(SMIN*8)+SSEC ! first seed
CALL ITIME(SHOUR,SMIN,SSEC) ! get time.
J=(SHOUR*64)+(SMIN*8)+SSEC ! second seed
CALL INIRND(I,J) ! init random number gen.
C
WINNER=PLAYER
THFPOS=OROOM(THIEF)
BLOC=OROOM(BALLO)
HERE=AROOM(WINNER)
LASTIT=AOBJ(PLAYER)
C
INITFL=.TRUE.
RETURN
C
C Errors-- INITFL fails.
C
1900 WRITE(OUTCH,910) ! dindx.dat open err
WRITE(OUTCH,980)
RETURN
1925 WRITE(OUTCH,920) I,J,KEDIT,VMAJ,VMIN,VEDIT ! wrong dindx.dat ver
WRITE(OUTCH,980)
RETURN
1950 WRITE(OUTCH,960) ! dtext.dat open err
WRITE(OUTCH,980)
RETURN
910 FORMAT(' I can''t open "DINDX.DAT".')
920 FORMAT(' "DINDX.DAT" is version ',I1,'.',I1,A,'.'/
1' I require version ',I1,'.',I1,A,'.')
960 FORMAT(' I can''t open "DTEXT.DAT".')
980 FORMAT(
1' Suddenly a sinister, wraithlike figure appears before you'/
1' seeming to float in the air. In a low, sorrowful voice he'/
2' says, "Alas, the very nature of the world has changed, and'/
3' the dungeon cannot be found. All must now pass away."'/
4' Raising his oaken staff in farewell, he fades into the'/
5' spreading darkness. In his place appears a tastefully'/
6' lettered sign reading:'//20X,'INITIALIZATION FAILURE'//
7' The darkness becomes all encompassing, and your vision fails.')
C
END
C PROTCT-- Check for user violation
C
C This routine should be modified if you wish to add system
c dependant protection against abuse.
C
C At the moment, play is permitted under all circumstances.
C
LOGICAL FUNCTION PROTCT(X)
IMPLICIT INTEGER (A-Z)
C
PROTCT=.TRUE.
RETURN
END